home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / defmacex.scm < prev    next >
Text File  |  1999-04-19  |  3KB  |  97 lines
  1. ;;;"defmacex.scm" defmacro:expand* for any Scheme dialect.
  2. ;;;Copyright 1993-1994 Dorai Sitaram and Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;;;expand thoroughly, not just topmost expression.  While expanding
  21. ;;;subexpressions, the primitive forms quote, lambda, set!, let/*/rec,
  22. ;;;cond, case, do, quasiquote: need to be destructured properly.  (if,
  23. ;;;and, or, begin: don't need special treatment.)
  24.  
  25. (define (defmacro:iqq e depth)
  26.   (letrec
  27.       ((map1 (lambda (f x)
  28.            (if (pair? x) (cons (f (car x)) (map1 f (cdr x)))
  29.            x)))
  30.        (iqq (lambda (e depth)
  31.           (if (pair? e)
  32.           (case (car e)
  33.             ((quasiquote) (list (car e) (iqq (cadr e) (+ 1 depth))))
  34.             ((unquote unquote-splicing)
  35.              (list (car e) (if (= 1 depth)
  36.                        (defmacro:expand* (cadr e))
  37.                        (iqq (cadr e) (+ -1 depth)))))
  38.             (else (map1 (lambda (e) (iqq e depth)) e)))
  39.           e))))
  40.     (iqq e depth)))
  41.  
  42. (define (defmacro:expand* e)
  43.   (if (pair? e)
  44.       (let* ((c (macroexpand-1 e)))
  45.     (if (not (eq? e c))
  46.         (defmacro:expand* c)
  47.         (case (car e)
  48.           ((quote) e)
  49.           ((quasiquote) (defmacro:iqq e 0))
  50.           ((lambda define set!)
  51.            (cons (car e) (cons (cadr e) (map defmacro:expand* (cddr e)))))
  52.           ((let)
  53.            (let ((b (cadr e)))
  54.          (if (symbol? b)    ;named let
  55.              `(let ,b
  56.             ,(map (lambda (vv)
  57.                 `(,(car vv)
  58.                   ,(defmacro:expand* (cadr vv))))
  59.                   (caddr e))
  60.             ,@(map defmacro:expand*
  61.                    (cdddr e)))
  62.              `(let
  63.               ,(map (lambda (vv)
  64.                   `(,(car vv)
  65.                     ,(defmacro:expand* (cadr vv))))
  66.                 b)
  67.             ,@(map defmacro:expand*
  68.                    (cddr e))))))
  69.           ((let* letrec)
  70.            `(,(car e) ,(map (lambda (vv)
  71.                   `(,(car vv)
  72.                     ,(defmacro:expand* (cadr vv))))
  73.                 (cadr e))
  74.               ,@(map defmacro:expand* (cddr e))))
  75.           ((cond)
  76.            `(cond
  77.          ,@(map (lambda (c)
  78.               (map defmacro:expand* c))
  79.             (cdr e))))
  80.           ((case)
  81.            `(case ,(defmacro:expand* (cadr e))
  82.           ,@(map (lambda (c)
  83.                `(,(car c)
  84.                  ,@(map defmacro:expand* (cdr c))))
  85.              (cddr e))))
  86.           ((do)
  87.            `(do ,(map
  88.               (lambda (initsteps)
  89.             `(,(car initsteps)
  90.               ,@(map defmacro:expand*
  91.                  (cdr initsteps))))
  92.               (cadr e))
  93.             ,(map defmacro:expand* (caddr e))
  94.           ,@(map defmacro:expand* (cdddr e))))
  95.           (else (map defmacro:expand* e)))))
  96.       e))
  97.